(***************************************************************************
 * phour - a program to calculate planetary and geomantic hour rulerships. *
 * Copyright (C) 2009 Sam Block.                                           *
 ***************************************************************************
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.	
 *)
 
open Printf
open Scanf

exception Bad_Input

type time = {
    hour    : int ;
    minute  : float ;
    length  : float ;
}

let promptForInfo = ref true
let suppress24HourTime = ref false
let showHourNames = ref false
let showPlanets = ref false
let showGeoFigures = ref false
let showExtra = ref false

let wd	= ref 9
let hr1, mr1 = (ref 25), (ref 60.0)
let hs, ms = (ref 25), (ref 60.0)
let hr2, mr2 = (ref 25), (ref 60.0)

let weekdayNames = 
    [ "Sunday"; "Monday"; "Tuesday"; "Wednesday"; "Thursday"; "Friday";
      "Saturday" ]

let planetsByDistance = 
    [ "Saturn"; "Jupiter"; "Mars"; "Sol"; "Venus"; "Mercury"; "Luna" ]

let planetaryOffset = [ 3; 6; 2; 5; 1; 4; 0 ]

let hourNames = 
    [ "Yayn"; "Janor"; "Nasnia"; "Salla"; "Sadedali"; "Thamur"; "Ourer"; 
      "Thamic"; "Neron"; "Jayon"; "Abai"; "Natalon"; "Beron"; "Barol"; "Thami"; 
      "Athar"; "Mathon"; "Rana"; "Netos"; "Tafrac"; "Sassur"; "Aglo"; "Calerva"; 
      "Salam" ]

let sundayGeoRulers = 
	[ "Fortuna Major"; "Amissio"; "Albus"; "Populus"; "Carcer"; "Acquisitio"; 
	  "Rubeus"; "Fortuna Minor"; "Puella"; "Conjunctio"; "Via"; "Tristitia";
	  "Laetitia"; "Puer"; "Fortuna Major"; "Amissio"; "Albus"; "Populus"; 
	  "Carcer"; "Acquisitio"; "Rubeus"; "Fortuna Minor"; "Puella"; 
	  "Conjunctio" ]

let mondayGeoRulers = 
	[ "Via"; "Carcer"; "Laetitia"; "Puer"; "Fortuna Major"; "Amissio"; "Albus"; 
	  "Populus"; "Tristitia"; "Acquisitio"; "Rubeus"; "Fortuna Minor"; "Puella"; 
	  "Albus"; "Via"; "Cauda Draconis"; "Laetitia"; "Puer"; "Fortuna Major"; 
	  "Amissio"; "Conjunctio"; "Populus"; "Carcer"; "Caput Draconis" ]

let tuesdayGeoRulers = 
	[ "Rubeus"; "Fortuna Minor"; "Puella"; "Albus"; "Via"; "Cauda Draconis"; 
	  "Acquisitio"; "Puer"; "Fortuna Major"; "Amissio"; "Conjunctio"; "Populus";
	  "Tristitia"; "Laetitia"; "Rubeus"; "Fortuna Major"; "Puella"; "Albus"; 
	  "Via"; "Carcer"; "Acquisitio"; "Cauda Draconis"; "Fortuna Minor"; 
	  "Amissio" ]
	  
let wednesdayGeoRulers = 
	[ "Albus"; "Populus"; "Tristitia"; "Laetitia"; "Puer"; "Fortuna Major"; 
	  "Puella"; "Conjunctio"; "Via"; "Carcer"; "Acquisitio"; "Rubeus";
	  "Fortuna Minor"; "Amissio"; "Albus"; "Populus"; "Tristitia"; "Acquisitio"; 
	  "Rubeus"; "Fortuna Major"; "Puella"; "Conjunctio"; "Via"; "Carcer" ]

let thursdayGeoRulers = 
	[ "Laetitia"; "Puer"; "Fortuna Minor"; "Amissio"; "Albus"; "Populus"; 
	  "Tristitia"; "Acquisitio"; "Rubeus"; "Fortuna Major"; "Puella"; 
	  "Conjunctio"; "Via"; "Carcer"; "Laetitia"; "Puer"; "Fortuna Minor"; 
	  "Amissio"; "Albus"; "Populus"; "Tristitia"; "Acquisitio"; "Rubeus"; 
	  "Fortuna Major" ]
	  
let fridayGeoRulers = 
	[ "Puella"; "Conjunctio"; "Via"; "Carcer"; "Laetitia"; "Puer";
	  "Fortuna Minor"; "Amissio"; "Albus"; "Populus"; "Tristitia"; "Acquisitio";
	  "Rubeus"; "Fortuna Major"; "Puella"; "Conjunctio"; "Via"; "Carcer"; 
	  "Laetitia"; "Puer"; "Fortuna Major"; "Amissio"; "Albus"; "Populus" ]
	  
let saturdayGeoRulers = 
	[ "Tristitia"; "Acquisitio"; "Rubeus"; "Fortuna Major"; "Puella"; 
	  "Conjunctio"; "Via"; "Carcer"; "Laetitia"; "Puer"; "Cauda Draconis"; 
	  "Amissio"; "Albus"; "Via"; "Tristitia"; "Acquisitio"; "Rubeus";
	  "Caput Draconis"; "Puella"; "Conjunctio"; "Populus"; "Carcer"; "Laetitia"; 
	  "Puer" ]
	  
let geoRulers =
	[ sundayGeoRulers; mondayGeoRulers; tuesdayGeoRulers; wednesdayGeoRulers; 
	  thursdayGeoRulers; fridayGeoRulers; saturdayGeoRulers ]

let make_time h m =
	{
		hour	= h ;
		minute	= m ;
		length	= (float_of_int (h * 60)) +. m ;
	}

let diff_time stime etime = begin
    let diff = etime.length -. stime.length in
    if diff >= 0.0
    then diff
    else diff +. 1440.0
end

let incr_time stime amnt = begin
	let nhour = ref (stime.hour) in
	let nmin = ref (stime.minute +. amnt) in
	while !nmin >= 60.0 do
		nmin := !nmin -. 60.0 ;
		nhour := (!nhour + 1) mod 24
	done ;
	{
		hour	= !nhour ;
		minute	= !nmin ;
		length	= (float_of_int (!nhour * 60)) +. !nmin ;
	}
end

let part_hours length = length /. 12.0

let string_of_time time = begin
	let get_little_hour time = begin
	    match time.hour with
	    | 0 -> 12
	    | _ -> if time.hour > 12
	        then time.hour - 12
	        else time.hour
	end in
	if !suppress24HourTime
	then begin
		let str = if time.hour < 12 then "a.m." else "p.m." in
		sprintf "%2i:%02i %s" 
		    (get_little_hour time) (int_of_float time.minute) str
	end
	else sprintf "%02i%02i" time.hour (int_of_float time.minute) ;
end

let check_time h m =
    if h > 23 || h < 0 || m >= 60.0 || m < 0.0 then false else true

let reattempt str f a = begin
	printf "%s\n" str ;
	flush stdout ;
	f a
end

let set_time str ht mt = begin
    if not (check_time !ht !mt)
    then begin
    	let rec get_input str = begin
    		let set a b = begin
    			if not (check_time (int_of_string a) (float_of_string b))
    			then raise Bad_Input
    	 		else (int_of_string a), (float_of_string b)
    	 	end in
     	 	printf "Enter the time of the %s (HH mm): " str ;
     	 	flush stdout ;
      		try scanf " %s %s\n" set
      		with _ -> reattempt "Bad input!  Please try again." get_input str
    	end in
    	let h, m = get_input str in
    	ht := h ;
	    mt := m
	end
end

let set_weekday () = begin
	let rec get_input () = 	
	    if !wd > 7 || !wd < 1
	    then begin
			printf "Enter the day of the week (1 as Sunday, 7 as Saturday): " ;
			flush stdout ;
			try
			    let i = int_of_string (scanf "%s\n" (fun p -> p)) in
			    if i > 7 || i < 1
			    then raise Bad_Input
			    else i
    		with _ -> reattempt "Bad input!  Please try again." get_input ()	
		end 
		else !wd 
	in
	wd := get_input ()
end	
	
let print_info trise1 tset uneq1 uneq2 wdn offset gl = begin
    let uneq i = if i < 12 then uneq1 else uneq2 in
  	let stime = ref trise1 in
  	for i = 0 to 23 do

        if !suppress24HourTime
        then begin 
            if i = 0
  	        then printf "Diurnal Hours for %s" wdn ;
  	        if i = 12
            then (printf "\n\nNocturnal Hours for %s" wdn ; stime := tset)
        end ;
        if i = 0 || i = 12 
        then begin 
            if !showExtra
            then printf " (%i minutes per unequal hour)"
                (int_of_float (uneq i)) ;
            printf "."
        end ;

  		printf "\n%2i. %s ~ "
  			(i + 1)
  			(string_of_time !stime) ;
  		stime := incr_time !stime (uneq i) ;
  		printf "%s " (string_of_time !stime) ;
  		
  		if !showHourNames 
  		then printf " %-9s" (List.nth hourNames i) ;
  		if !showPlanets
  		then printf " %-8s" (List.nth planetsByDistance ((offset + i) mod 7)) ;
  		if !showGeoFigures
  		then printf " %-16s" (List.nth gl i) ;
  	done ;
  	printf "\n"
end

let set_state () = begin
    if !promptForInfo
    then begin
       	let rec get_state question setting = begin
		try begin
		    printf "%s (y/n): " question ;
		    let c = read_line () in
		    match c with
		    | "y" -> setting := true
		    | "n" -> setting := false
		    | _ -> raise Bad_Input
		end 
		with _ -> begin
		    printf "Bad input!  Please try again.\n" ;
		    get_state question setting
		    end
        end in
        get_state "Use 12-hour a.m./p.m. format?" suppress24HourTime ;
        get_state "Show calculation information?" showExtra ;
        get_state "Show the magickal hour names?" showHourNames ;
        get_state "Show the planetary rulers?" showPlanets ;
        get_state "Show the geomantic rulers?" showGeoFigures
    end
end 

let graceful_exit () = begin
    let _ = 
        if not (Sys.os_type = "Unix")
        then begin
            printf "\nPress return to exit.\n" ;
            flush stdout ;
            ignore(input_char stdin)
        end
    in
    exit 0
end

let main () = begin
	printf "\n\
        ----------------------------------------------------------------------\
        ---------\n\
        phour, copyright (C) 2009 Sam Block.\n\
        This program comes with ABSOLUTELY NO WARRANTY.  This is free software\
        , and you\n\
        are welcome to redistribute it under certain conditions.  Please see t\
        he GNU\n\
        General Public License (version 3 or later) for details.\n\
        ----------------------------------------------------------------------\
        ---------\n\
        \n"	;

	let usageMsg = "phour - displays unequal hours and rulers" in
	let tr1	= [Arg.Set_int hr1 ; Arg.Set_float mr1 ] in
	let ts	= [Arg.Set_int hs ; Arg.Set_float ms ] in
	let tr2	= [Arg.Set_int hr2 ; Arg.Set_float mr2 ] in
	let args = [
	    "--noprompt", Arg.Clear promptForInfo, " don't prompt for settings" ;
        "--extra", Arg.Set showExtra, " show extra information" ;
        "--day", Arg.Set_int wd, "X set the weekday to X (between 1 and 7)" ;
		"--rise1", Arg.Tuple tr1, "XY set the time of the first sunrise (HH\
		mm)" ;
		"--set", Arg.Tuple ts, "XY set the time of the sunset (HH mm)" ;
		"--rise2", Arg.Tuple tr2, "XY set the time of the second sunrise (HH\
		mm)" ;		
		"--ampm", Arg.Set suppress24HourTime, " show times in 12-hour format" ;
		"--names", Arg.Set showHourNames, " show the magickal hour names" ;
		"--planetary", Arg.Set showPlanets, " show the planetary rulers" ;
		"--geomantic", Arg.Set showGeoFigures, " show the geomantic rulers\n" ;
	] in
	Arg.parse (Arg.align args) (fun f -> ()) usageMsg ;

    set_state () ;
    set_weekday () ;
    set_time "first sunrise" hr1 mr1 ;
    set_time "sunset" hs ms ;
    set_time "second sunrise" hr2 mr2 ;

	let trise1  = make_time !hr1 !mr1 in
	let tset    = make_time !hs !ms in
	let trise2  = make_time !hr2 !mr2 in
	let uneq1   = part_hours (diff_time trise1 tset) in
	let uneq2   = part_hours (diff_time tset trise2) in
	let wdn     = List.nth weekdayNames (!wd - 1) in
	let gl      = List.nth geoRulers (!wd - 1) in
	let offset  = List.nth planetaryOffset (!wd - 1) in 
    
    print_info trise1 tset uneq1 uneq2 wdn offset gl ;
   
    graceful_exit ()
end ;;
main ()
